{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Tracing.OrphanInstances.Consensus () where

import           Cardano.Node.Tracing.Tracers.ConsensusStartupException
                   (ConsensusStartupException (..))
import           Cardano.Prelude (Typeable, maximumDef)
import           Cardano.Slotting.Slot (fromWithOrigin)
import           Cardano.Tracing.OrphanInstances.Common
import           Cardano.Tracing.OrphanInstances.Network ()
import           Cardano.Tracing.Render (renderChainHash, renderChunkNo, renderHeaderHash,
                   renderHeaderHashForVerbosity, renderPointAsPhrase, renderPointForVerbosity,
                   renderRealPoint, renderRealPointAsPhrase, renderTipBlockNo, renderTipHash,
                   renderWithOrigin)
import           Ouroboros.Consensus.Block (BlockProtocol, BlockSupportsProtocol, CannotForge,
                   ConvertRawHash (..), ForgeStateUpdateError, GenesisWindow (..), GetHeader (..),
                   Header, RealPoint (..), blockNo, blockPoint, blockPrevHash, getHeader, pointHash,
                   realPointHash, realPointSlot, withOriginToMaybe)
import           Ouroboros.Consensus.Block.SupportsSanityCheck
import           Ouroboros.Consensus.Genesis.Governor (DensityBounds (..), GDDDebugInfo (..),
                   TraceGDDEvent (..))
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent (..), LedgerUpdate,
                   LedgerWarning)
import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, ByteSize32 (..), GenTx,
                   GenTxId, HasTxId, LedgerSupportsMempool, TxId, txForgetValidated, txId)
import           Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol)
import           Ouroboros.Consensus.Mempool (MempoolSize (..), TraceEventMempool (..))
import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
                   (TraceBlockFetchServerEvent (..))
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client (TraceChainSyncClientEvent (..))
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as ChainSync.Client
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State as ChainSync.Client
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server (BlockingType (..),
                   TraceChainSyncServerEvent (..))
import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
                   (TraceLocalTxSubmissionServerEvent (..))
import           Ouroboros.Consensus.Node.GSM
import           Ouroboros.Consensus.Node.Run (RunNode, estimateBlockSize)
import           Ouroboros.Consensus.Node.Tracers (TraceForgeEvent (..))
import qualified Ouroboros.Consensus.Node.Tracers as Consensus
import           Ouroboros.Consensus.Protocol.Abstract
import qualified Ouroboros.Consensus.Protocol.BFT as BFT
import qualified Ouroboros.Consensus.Protocol.PBFT as PBFT
import           Ouroboros.Consensus.Protocol.Praos.AgentClient
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmDB
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkNo (..),
                   chunkNoToInt)
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB
import           Ouroboros.Consensus.Storage.LedgerDB (PushGoal (..), PushStart (..), Pushing (..))
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB
import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolDb
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Enclose
import           Ouroboros.Consensus.Util.Orphans ()
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), MaxSlotNo (..),
                   SlotNo (..), StandardHash, Tip (..), blockHash, pointSlot, tipFromHeader)
import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
import           Ouroboros.Network.Point (withOrigin)
import           Ouroboros.Network.SizeInBytes (SizeInBytes (..))

import           Control.Monad (guard)
import           Control.Exception
import           Data.Aeson (Value (..))
import qualified Data.Aeson as Aeson
import           Data.Foldable (Foldable (..))
import           Data.Function (on)
import           Data.Proxy
import           Data.Text (Text, pack)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Word (Word32)
import           GHC.Generics (Generic)
import           Network.TypedProtocol.Core
import           Numeric (showFFloat)
import qualified Cardano.KESAgent.Processes.ServiceClient as Agent


{- HLINT ignore "Use const" -}
{- HLINT ignore "Use record patterns" -}

instance ToObject ConsensusStartupException where
  toObject _ (ConsensusStartupException err) =
    mconcat
      [ "kind" .= String "ConsensusStartupException"
      , "error" .= String (pack . show $ err)
      ]

instance HasPrivacyAnnotation ConsensusStartupException where
instance HasSeverityAnnotation ConsensusStartupException where
  getSeverityAnnotation _ = Critical
instance Transformable Text IO ConsensusStartupException where
  trTransformer = trStructured
instance HasTextFormatter ConsensusStartupException where

instance HasPrivacyAnnotation SanityCheckIssue
instance HasSeverityAnnotation SanityCheckIssue where
  getSeverityAnnotation _ = Error
instance Transformable Text IO SanityCheckIssue where
  trTransformer = trStructured

instance ToObject SanityCheckIssue where
  toObject _verb issue =
    mconcat
      [ "kind" .= String "SanityCheckIssue"
      , "issue" .= toJSON issue
      ]
instance ToJSON SanityCheckIssue where
  toJSON = Aeson.String . pack . show

instance ConvertRawHash blk => ConvertRawHash (Header blk) where
  toShortRawHash _ = toShortRawHash (Proxy @blk)
  fromShortRawHash _ = fromShortRawHash (Proxy @blk)
  hashSize :: proxy (Header blk) -> Word32
  hashSize _ = hashSize (Proxy @blk)

instance ConvertRawHash blk => ConvertRawHash (HeaderWithTime blk) where
  toShortRawHash _ = toShortRawHash (Proxy @blk)
  fromShortRawHash _ = fromShortRawHash (Proxy @blk)
  hashSize :: proxy (HeaderWithTime blk) -> Word32
  hashSize _ = hashSize (Proxy @blk)

--
-- * instances of @HasPrivacyAnnotation@ and @HasSeverityAnnotation@
--
-- NOTE: this list is sorted by the unqualified name of the outermost type.

instance HasPrivacyAnnotation (ChainDB.TraceEvent blk)
instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where
  getSeverityAnnotation (ChainDB.TraceAddBlockEvent ev) = case ev of
    ChainDB.IgnoreBlockOlderThanImmTip {} -> Info
    ChainDB.IgnoreBlockAlreadyInVolatileDB {} -> Info
    ChainDB.IgnoreInvalidBlock {} -> Info
    ChainDB.AddedBlockToQueue {} -> Debug
    ChainDB.PoppedBlockFromQueue {} -> Debug
    ChainDB.PoppingFromQueue {} -> Debug
    ChainDB.AddedBlockToVolatileDB {} -> Debug
    ChainDB.TryAddToCurrentChain {} -> Debug
    ChainDB.TrySwitchToAFork {} -> Info
    ChainDB.StoreButDontChange {} -> Debug
    ChainDB.ChangingSelection {} -> Debug
    ChainDB.AddedToCurrentChain events _ _ _ ->
      maximumDef Notice (map getSeverityAnnotation events)
    ChainDB.SwitchedToAFork events _ _ _ ->
      maximumDef Notice (map getSeverityAnnotation events)
    ChainDB.AddBlockValidation ev' -> case ev' of
      ChainDB.InvalidBlock {} -> Error
      ChainDB.ValidCandidate {} -> Info
      ChainDB.UpdateLedgerDbTraceEvent {} -> Debug
    ChainDB.PipeliningEvent {} -> Debug
    ChainDB.AddedReprocessLoEBlocksToQueue {} -> Debug
    ChainDB.PoppedReprocessLoEBlocksFromQueue -> Debug
    ChainDB.ChainSelectionLoEDebug _ _ -> Debug


  getSeverityAnnotation (ChainDB.TraceLedgerDBEvent ev) = case ev of
    LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of
      LedgerDB.TookSnapshot {} -> Info
      LedgerDB.DeletedSnapshot {} -> Debug
      LedgerDB.InvalidSnapshot _ invalidWhy -> case invalidWhy of
        LedgerDB.InitFailureRead (LedgerDB.ReadMetadataError _ LedgerDB.MetadataBackendMismatch) -> Warning
        LedgerDB.InitFailureRead (LedgerDB.ReadMetadataError _ LedgerDB.MetadataFileDoesNotExist) -> Warning
        _ -> Error
    LedgerDB.LedgerReplayEvent {} -> Info
    LedgerDB.LedgerDBForkerEvent {} -> Debug
    LedgerDB.LedgerDBFlavorImplEvent {} -> Debug

  getSeverityAnnotation (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of
    ChainDB.CopiedBlockToImmutableDB {} -> Debug
    ChainDB.NoBlocksToCopyToImmutableDB -> Debug

  getSeverityAnnotation (ChainDB.TraceGCEvent ev) = case ev of
    ChainDB.PerformedGC {} -> Debug
    ChainDB.ScheduledGC {} -> Debug

  getSeverityAnnotation (ChainDB.TraceOpenEvent ev) = case ev of
    ChainDB.OpenedDB {} -> Info
    ChainDB.ClosedDB {} -> Info
    ChainDB.OpenedImmutableDB {} -> Info
    ChainDB.OpenedVolatileDB {} -> Info
    ChainDB.OpenedLgrDB -> Info
    ChainDB.StartedOpeningDB -> Info
    ChainDB.StartedOpeningImmutableDB -> Info
    ChainDB.StartedOpeningVolatileDB -> Info
    ChainDB.StartedOpeningLgrDB -> Info

  getSeverityAnnotation (ChainDB.TraceFollowerEvent ev) = case ev of
    ChainDB.NewFollower {} -> Debug
    ChainDB.FollowerNoLongerInMem {} -> Debug
    ChainDB.FollowerSwitchToMem {} -> Debug
    ChainDB.FollowerNewImmIterator {} -> Debug
  getSeverityAnnotation (ChainDB.TraceInitChainSelEvent ev) = case ev of
    ChainDB.StartedInitChainSelection{} -> Info
    ChainDB.InitialChainSelected{} -> Info
    ChainDB.InitChainSelValidation ev' -> case ev' of
      ChainDB.InvalidBlock{} -> Debug
      ChainDB.ValidCandidate {} -> Info
      ChainDB.UpdateLedgerDbTraceEvent {} -> Info

  getSeverityAnnotation (ChainDB.TraceIteratorEvent ev) = case ev of
    ChainDB.StreamFromVolatileDB {} -> Debug
    _ -> Debug
  getSeverityAnnotation (ChainDB.TraceImmutableDBEvent ev) = case ev of
    ImmDB.NoValidLastLocation {} -> Info
    ImmDB.ValidatedLastLocation {} -> Info
    ImmDB.ChunkValidationEvent ev' -> case ev' of
      ImmDB.StartedValidatingChunk{} -> Info
      ImmDB.ValidatedChunk{}         -> Info
      ImmDB.MissingChunkFile{}       -> Warning
      ImmDB.InvalidChunkFile {}      -> Warning
      ImmDB.MissingPrimaryIndex{}    -> Warning
      ImmDB.MissingSecondaryIndex{}  -> Warning
      ImmDB.InvalidPrimaryIndex{}    -> Warning
      ImmDB.InvalidSecondaryIndex{}  -> Warning
      ImmDB.RewritePrimaryIndex{}    -> Warning
      ImmDB.RewriteSecondaryIndex{}  -> Warning
    ImmDB.ChunkFileDoesntFit{} -> Warning
    ImmDB.Migrating{}          -> Debug
    ImmDB.DeletingAfter{}      -> Debug
    ImmDB.DBAlreadyClosed{}    -> Error
    ImmDB.DBClosed{}           -> Info
    ImmDB.TraceCacheEvent{}    -> Debug
  getSeverityAnnotation (ChainDB.TraceVolatileDBEvent ev) = case ev of
    VolDb.DBAlreadyClosed{}     -> Error
    VolDb.BlockAlreadyHere{}    -> Debug
    VolDb.Truncate{}            -> Error
    VolDb.InvalidFileNames{}    -> Warning
    VolDb.DBClosed{}            -> Info
  getSeverityAnnotation ChainDB.TraceLastShutdownUnclean = Warning

  getSeverityAnnotation ChainDB.TraceChainSelStarvationEvent{} = Debug

instance HasSeverityAnnotation (LedgerEvent blk) where
  getSeverityAnnotation (LedgerUpdate _)  = Notice
  getSeverityAnnotation (LedgerWarning _) = Critical

instance HasPrivacyAnnotation (TraceBlockFetchServerEvent blk)
instance HasSeverityAnnotation (TraceBlockFetchServerEvent blk) where
  getSeverityAnnotation _ = Info

instance (ToObject peer, ToObject (TraceChainSyncClientEvent blk))
    => Transformable Text IO (TraceLabelPeer peer (TraceChainSyncClientEvent blk)) where
  trTransformer = trStructured
instance (BlockSupportsProtocol blk, Show peer, Show (Header blk))
    => HasTextFormatter (TraceLabelPeer peer (TraceChainSyncClientEvent blk)) where
  formatText a _ = pack $ show a

instance HasPrivacyAnnotation (TraceChainSyncClientEvent blk)
instance HasSeverityAnnotation (TraceChainSyncClientEvent blk) where
  getSeverityAnnotation (TraceDownloadedHeader _) = Info
  getSeverityAnnotation (TraceFoundIntersection _ _ _) = Info
  getSeverityAnnotation (TraceRolledBack _) = Notice
  getSeverityAnnotation (TraceException _) = Warning
  getSeverityAnnotation (TraceTermination _) = Notice
  getSeverityAnnotation (TraceValidatedHeader _) = Debug
  getSeverityAnnotation (TraceWaitingBeyondForecastHorizon _) = Debug
  getSeverityAnnotation (TraceAccessingForecastHorizon _) = Debug
  getSeverityAnnotation (TraceGaveLoPToken _ _ _) = Debug
  getSeverityAnnotation (TraceOfferJump _) = Debug
  getSeverityAnnotation (TraceJumpResult _) = Debug
  getSeverityAnnotation TraceJumpingWaitingForNextInstruction = Debug
  getSeverityAnnotation (TraceJumpingInstructionIs _) = Debug
  getSeverityAnnotation (TraceDrainingThePipe _) = Debug


instance HasPrivacyAnnotation (TraceChainSyncServerEvent blk)
instance HasSeverityAnnotation (TraceChainSyncServerEvent blk) where
  getSeverityAnnotation _ = Info


instance HasPrivacyAnnotation (TraceEventMempool blk)
instance HasSeverityAnnotation (TraceEventMempool blk) where
  getSeverityAnnotation TraceMempoolAddedTx{} = Info
  getSeverityAnnotation TraceMempoolTipMovedBetweenSTMBlocks{} = Info
  getSeverityAnnotation TraceMempoolRejectedTx{} = Info
  getSeverityAnnotation TraceMempoolRemoveTxs{} = Debug
  getSeverityAnnotation TraceMempoolManuallyRemovedTxs{} = Warning
  getSeverityAnnotation TraceMempoolSyncNotNeeded{} = Debug
  getSeverityAnnotation TraceMempoolSynced{} = Debug
  getSeverityAnnotation TraceMempoolAttemptingAdd{} = Debug

instance HasPrivacyAnnotation ()
instance HasSeverityAnnotation () where
  getSeverityAnnotation () = Info

instance HasPrivacyAnnotation (TraceForgeEvent blk)
instance HasSeverityAnnotation (TraceForgeEvent blk) where
  getSeverityAnnotation TraceStartLeadershipCheck {}   = Info
  getSeverityAnnotation TraceSlotIsImmutable {}        = Error
  getSeverityAnnotation TraceBlockFromFuture {}        = Error
  getSeverityAnnotation TraceBlockContext {}           = Debug
  getSeverityAnnotation TraceNoLedgerState {}          = Error
  getSeverityAnnotation TraceLedgerState {}            = Debug
  getSeverityAnnotation TraceNoLedgerView {}           = Error
  getSeverityAnnotation TraceLedgerView {}             = Debug
  getSeverityAnnotation TraceForgeStateUpdateError {}  = Error
  getSeverityAnnotation TraceNodeCannotForge {}        = Error
  getSeverityAnnotation TraceNodeNotLeader {}          = Info
  getSeverityAnnotation TraceNodeIsLeader {}           = Info
  getSeverityAnnotation TraceForgeTickedLedgerState {} = Debug
  getSeverityAnnotation TraceForgingMempoolSnapshot {} = Debug
  getSeverityAnnotation TraceForgedBlock {}            = Info
  getSeverityAnnotation TraceDidntAdoptBlock {}        = Error
  getSeverityAnnotation TraceForgedInvalidBlock {}     = Error
  getSeverityAnnotation TraceAdoptedBlock {}           = Info
  getSeverityAnnotation TraceAdoptionThreadDied {}     = Error


instance HasPrivacyAnnotation (TraceLocalTxSubmissionServerEvent blk)
instance HasSeverityAnnotation (TraceLocalTxSubmissionServerEvent blk) where
  getSeverityAnnotation _ = Info


--
-- | instances of @Transformable@
--
-- NOTE: this list is sorted by the unqualified name of the outermost type.

instance ( HasPrivacyAnnotation (ChainDB.TraceAddBlockEvent blk)
         , HasSeverityAnnotation (ChainDB.TraceAddBlockEvent blk)
         , LedgerSupportsProtocol blk
         , ToObject (ChainDB.TraceAddBlockEvent blk))
      => Transformable Text IO (ChainDB.TraceAddBlockEvent blk) where
  trTransformer = trStructuredText


instance (LedgerSupportsProtocol blk)
      => HasTextFormatter (ChainDB.TraceAddBlockEvent blk) where
  formatText _ = pack . show . toList


instance (ToObject peer, ConvertRawHash blk)
      => Transformable Text IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) where
  trTransformer = trStructuredText


instance HasTextFormatter (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) where
  formatText _ = pack . show . toList


instance (ConvertRawHash blk, LedgerSupportsProtocol blk)
      => Transformable Text IO (TraceChainSyncClientEvent blk) where
  trTransformer = trStructured


instance ConvertRawHash blk
      => Transformable Text IO (TraceChainSyncServerEvent blk) where
  trTransformer = trStructured

instance (ToObject peer, ToObject (TraceChainSyncServerEvent blk))
    => Transformable Text IO (TraceLabelPeer peer (TraceChainSyncServerEvent blk)) where
  trTransformer = trStructured
instance (StandardHash blk, Show peer)
    => HasTextFormatter (TraceLabelPeer peer (TraceChainSyncServerEvent blk)) where
  formatText a _ = pack $ show a


instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk),
           ToJSON (GenTxId blk), LedgerSupportsMempool blk,
           ConvertRawHash blk)
      => Transformable Text IO (TraceEventMempool blk) where
  trTransformer = trStructured

instance Condense t => Condense (Enclosing' t) where
  condense RisingEdge = "RisingEdge"
  condense (FallingEdgeWith a) = "FallingEdge: " <> condense a

deriving instance Generic (Enclosing' t)
instance ToJSON t => ToJSON (Enclosing' t)

condenseT :: Condense a => a -> Text
condenseT = pack . condense

showT :: Show a => a -> Text
showT = pack . show


instance ( tx ~ GenTx blk
         , HasTxId tx
         , RunNode blk
         , ToObject (LedgerError blk)
         , ToObject (OtherHeaderEnvelopeError blk)
         , ToObject (ValidationErr (BlockProtocol blk))
         , ToObject (CannotForge blk)
         , ToObject (ForgeStateUpdateError blk)
         , LedgerSupportsMempool blk)
      => Transformable Text IO (TraceForgeEvent blk) where
  trTransformer = trStructuredText

instance ( tx ~ GenTx blk
         , ConvertRawHash blk
         , HasTxId tx
         , LedgerSupportsMempool blk
         , LedgerSupportsProtocol blk
         , LedgerSupportsMempool blk
         , Show (TxId tx)
         , Show (ForgeStateUpdateError blk)
         , Show (CannotForge blk)
         , LedgerSupportsMempool blk)
      => HasTextFormatter (TraceForgeEvent blk) where
  formatText = \case
    TraceStartLeadershipCheck slotNo -> const $
      "Checking for leadership in slot " <> showT (unSlotNo slotNo)
    TraceSlotIsImmutable slotNo immutableTipPoint immutableTipBlkNo -> const $
      "Couldn't forge block because current slot is immutable: "
        <> "immutable tip: " <> renderPointAsPhrase immutableTipPoint
        <> ", immutable tip block no: " <> showT (unBlockNo immutableTipBlkNo)
        <> ", current slot: " <> showT (unSlotNo slotNo)
    TraceBlockFromFuture currentSlot tipSlot -> const $
      "Couldn't forge block because current tip is in the future: "
        <> "current tip slot: " <> showT (unSlotNo tipSlot)
        <> ", current slot: " <> showT (unSlotNo currentSlot)
    TraceBlockContext currentSlot tipBlockNo tipPoint -> const $
      "New block will fit onto: "
        <> "tip: " <> renderPointAsPhrase tipPoint
        <> ", tip block no: " <> showT (unBlockNo tipBlockNo)
        <> ", current slot: " <> showT (unSlotNo currentSlot)
    TraceNoLedgerState slotNo pt -> const $
      "Could not obtain ledger state for point "
        <> renderPointAsPhrase pt
        <> ", current slot: "
        <> showT (unSlotNo slotNo)
    TraceLedgerState slotNo pt -> const $
      "Obtained a ledger state for point "
        <> renderPointAsPhrase pt
        <> ", current slot: "
        <> showT (unSlotNo slotNo)
    TraceNoLedgerView slotNo _ -> const $
      "Could not obtain ledger view for slot " <> showT (unSlotNo slotNo)
    TraceLedgerView slotNo -> const $
      "Obtained a ledger view for slot " <> showT (unSlotNo slotNo)
    TraceForgeStateUpdateError slotNo reason -> const $
      "Updating the forge state in slot "
        <> showT (unSlotNo slotNo)
        <> " failed because: "
        <> showT reason
    TraceNodeCannotForge slotNo reason -> const $
      "We are the leader in slot "
        <> showT (unSlotNo slotNo)
        <> ", but we cannot forge because: "
        <> showT reason
    TraceNodeNotLeader slotNo -> const $
      "Not leading slot " <> showT (unSlotNo slotNo)
    TraceNodeIsLeader slotNo -> const $
      "Leading slot " <> showT (unSlotNo slotNo)
    TraceForgeTickedLedgerState slotNo prevPt -> const $
      "While forging in slot "
        <> showT (unSlotNo slotNo)
        <> " we ticked the ledger state ahead from "
        <> renderPointAsPhrase prevPt
    TraceForgingMempoolSnapshot slotNo prevPt mpHash mpSlot -> const $
      "While forging in slot "
        <> showT (unSlotNo slotNo)
        <> " we acquired a mempool snapshot valid against "
        <> renderPointAsPhrase prevPt
        <> " from a mempool that was prepared for "
        <> renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) mpHash
        <> " ticked to slot "
        <> showT (unSlotNo mpSlot)
    TraceForgedBlock slotNo _ _ _ -> const $
      "Forged block in slot " <> showT (unSlotNo slotNo)
    TraceDidntAdoptBlock slotNo _ -> const $
      "Didn't adopt forged block in slot " <> showT (unSlotNo slotNo)
    TraceForgedInvalidBlock slotNo _ reason -> const $
      "Forged invalid block in slot "
        <> showT (unSlotNo slotNo)
        <> ", reason: " <> showT reason
    TraceAdoptedBlock slotNo blk txs -> const $
      "Adopted block forged in slot "
        <> showT (unSlotNo slotNo)
        <> ": " <> renderHeaderHash (Proxy @blk) (blockHash blk)
        <> ", TxIds: " <> showT (map (txId . txForgetValidated) txs)
    TraceAdoptionThreadDied slotNo blk -> const $
      "Adoption Thread died in slot "
        <> showT (unSlotNo slotNo)
        <> ": " <> renderHeaderHash (Proxy @blk) (blockHash blk)


instance Transformable Text IO (TraceLocalTxSubmissionServerEvent blk) where
  trTransformer = trStructured

instance HasPrivacyAnnotation a => HasPrivacyAnnotation (Consensus.TraceLabelCreds a)
instance HasSeverityAnnotation a => HasSeverityAnnotation (Consensus.TraceLabelCreds a) where
  getSeverityAnnotation (Consensus.TraceLabelCreds _ a) = getSeverityAnnotation a

instance ToObject a => ToObject (Consensus.TraceLabelCreds a) where
  toObject verb (Consensus.TraceLabelCreds creds val) =
    mconcat [ "credentials" .= toJSON creds
            , "val"         .= toObject verb val
            ]

instance (HasPrivacyAnnotation a, HasSeverityAnnotation a, ToObject a)
      => Transformable Text IO (Consensus.TraceLabelCreds a) where
  trTransformer = trStructured

instance ( ConvertRawHash blk
         , LedgerSupportsProtocol blk
         , InspectLedger blk
         , ToObject (Header blk)
         , ToObject (LedgerEvent blk)
         , ToObject (SelectView (BlockProtocol blk)))
      => Transformable Text IO (ChainDB.TraceEvent blk) where
  trTransformer = trStructuredText

instance ( ConvertRawHash blk
         , LedgerSupportsProtocol blk
         , InspectLedger blk)
      => HasTextFormatter (ChainDB.TraceEvent blk) where
    formatText tev _obj = case tev of
      ChainDB.TraceLastShutdownUnclean -> "ChainDB is not clean. Validating all immutable chunks"
      ChainDB.TraceAddBlockEvent ev -> case ev of
        ChainDB.IgnoreBlockOlderThanImmTip pt ->
          "Ignoring block older than ImmTip: " <> renderRealPointAsPhrase pt
        ChainDB.IgnoreBlockAlreadyInVolatileDB pt ->
          "Ignoring block already in DB: " <> renderRealPointAsPhrase pt
        ChainDB.IgnoreInvalidBlock pt _reason ->
          "Ignoring previously seen invalid block: " <> renderRealPointAsPhrase pt
        ChainDB.AddedBlockToQueue pt edgeSz ->
          case edgeSz of
            RisingEdge ->
              "About to add block to queue: " <> renderRealPointAsPhrase pt
            FallingEdgeWith sz ->
              "Block added to queue: " <> renderRealPointAsPhrase pt <> " queue size " <> condenseT sz
        ChainDB.AddedReprocessLoEBlocksToQueue {} ->
          "Added request to queue to reprocess blocks postponed by LoE."
        ChainDB.PoppedReprocessLoEBlocksFromQueue ->
          "Poppped request from queue to reprocess blocks postponed by LoE."
        ChainDB.ChainSelectionLoEDebug {} ->
          "ChainDB LoE debug event"
        ChainDB.PoppingFromQueue ->
          "Popping block from queue"
        ChainDB.PoppedBlockFromQueue pt ->
          "Popped block from queue: " <> renderRealPointAsPhrase pt
        ChainDB.StoreButDontChange pt ->
          "Ignoring block: " <> renderRealPointAsPhrase pt
        ChainDB.TryAddToCurrentChain pt ->
          "Block fits onto the current chain: " <> renderRealPointAsPhrase pt
        ChainDB.TrySwitchToAFork pt _ ->
          "Block fits onto some fork: " <> renderRealPointAsPhrase pt
        ChainDB.ChangingSelection pt ->
          "Changing selection to: " <> renderPointAsPhrase pt
        ChainDB.AddedToCurrentChain es _ _ c ->
          "Chain extended, new tip: " <> renderPointAsPhrase (AF.headPoint c) <>
          Text.concat [ "\nEvent: " <> showT e | e <- es ]
        ChainDB.SwitchedToAFork es _ _ c ->
          "Switched to a fork, new tip: " <> renderPointAsPhrase (AF.headPoint c) <>
          Text.concat [ "\nEvent: " <> showT e | e <- es ]
        ChainDB.AddBlockValidation ev' -> case ev' of
          ChainDB.InvalidBlock err pt ->
            "Invalid block " <> renderRealPointAsPhrase pt <> ": " <> showT err
          ChainDB.ValidCandidate c ->
            "Valid candidate spanning from " <> renderPointAsPhrase (AF.lastPoint c) <> " to " <> renderPointAsPhrase (AF.headPoint c)
          ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb  (PushStart start) (PushGoal goal) (Pushing curr)) ->
            let fromSlot = unSlotNo $ realPointSlot start
                atSlot   = unSlotNo $ realPointSlot curr
                atDiff   = atSlot - fromSlot
                toSlot   = unSlotNo $ realPointSlot goal
                toDiff   = toSlot - fromSlot
            in
              "Pushing ledger state for block " <> renderRealPointAsPhrase curr <> ". Progress: " <>
              showProgressT (fromIntegral atDiff) (fromIntegral toDiff) <> "%"
        ChainDB.AddedBlockToVolatileDB pt _ _ enclosing -> case enclosing of
          RisingEdge  -> "Chain about to add block " <> renderRealPointAsPhrase pt
          FallingEdge -> "Chain added block " <> renderRealPointAsPhrase pt
        ChainDB.PipeliningEvent ev' -> case ev' of
          ChainDB.SetTentativeHeader hdr enclosing -> case enclosing of
            RisingEdge  -> "About to set tentative header to " <> renderPointAsPhrase (blockPoint hdr)
            FallingEdge -> "Set tentative header to " <> renderPointAsPhrase (blockPoint hdr)
          ChainDB.TrapTentativeHeader hdr -> "Discovered trap tentative header " <> renderPointAsPhrase (blockPoint hdr)
          ChainDB.OutdatedTentativeHeader hdr -> "Tentative header is now outdated" <> renderPointAsPhrase (blockPoint hdr)

      ChainDB.TraceLedgerDBEvent ev -> case ev of
        LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of
          LedgerDB.InvalidSnapshot snap failure ->
            "Invalid snapshot " <> showT snap <> showT failure <> context
            where
              context = case failure of
                LedgerDB.InitFailureRead LedgerDB.ReadSnapshotFailed{} ->
                     " This is most likely an expected change in the serialization format,"
                  <> " which currently requires a chain replay"
                LedgerDB.InitFailureRead LedgerDB.ReadSnapshotDataCorruption ->
                     " The snapshot fails the CRC check. It seems there has been disk corruption"
                LedgerDB.InitFailureRead (LedgerDB.ReadMetadataError _ err) -> case err of
                  LedgerDB.MetadataFileDoesNotExist ->
                     " The snapshot doesn't have the required metadata file."
                  LedgerDB.MetadataInvalid errMsg ->
                     " Snapshot metadata file failed to deserialize: " <> showT errMsg
                  LedgerDB.MetadataBackendMismatch ->
                     " Snapshot was created for a different backend. Convert it with `snapshot-converter`."
                _ -> ""
          LedgerDB.TookSnapshot snap pt RisingEdge ->
            "Taking ledger snapshot " <> showT snap <>
            " at " <> renderRealPointAsPhrase pt
          LedgerDB.TookSnapshot snap pt (FallingEdgeWith t) ->
            "Took ledger snapshot " <> showT snap <>
            " at " <> renderRealPointAsPhrase pt <>
            ", duration: " <> showT t
          LedgerDB.DeletedSnapshot snap ->
            "Deleted old snapshot " <> showT snap
        LedgerDB.LedgerReplayEvent ev' -> case ev' of
          LedgerDB.TraceReplayStartEvent ev'' -> case ev'' of
            LedgerDB.ReplayFromGenesis ->
              "Replaying ledger from genesis"
            LedgerDB.ReplayFromSnapshot _ (LedgerDB.ReplayStart tip') ->
              "Replaying ledger from snapshot at " <>
                renderPointAsPhrase tip'
          LedgerDB.TraceReplayProgressEvent
            (LedgerDB.ReplayedBlock pt _ledgerEvents (LedgerDB.ReplayStart replayFrom) (LedgerDB.ReplayGoal replayTo)) ->
            let fromSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayFrom
                atSlot   = unSlotNo $ realPointSlot pt
                atDiff   = atSlot - fromSlot
                toSlot   = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayTo
                toDiff   = toSlot - fromSlot
            in
               "Replayed block: slot "
            <> showT atSlot
            <> " out of "
            <> showT toSlot
            <> ". Progress: "
            <> showProgressT (fromIntegral atDiff) (fromIntegral toDiff)
            <> "%"
        LedgerDB.LedgerDBForkerEvent ev' -> showT ev'
        LedgerDB.LedgerDBFlavorImplEvent ev' -> showT ev'

      ChainDB.TraceCopyToImmutableDBEvent ev -> case ev of
        ChainDB.CopiedBlockToImmutableDB pt ->
          "Copied block " <> renderPointAsPhrase pt <> " to the ImmutableDB"
        ChainDB.NoBlocksToCopyToImmutableDB ->
          "There are no blocks to copy to the ImmutableDB"
      ChainDB.TraceGCEvent ev -> case ev of
        ChainDB.PerformedGC slot ->
          "Performed a garbage collection for " <> condenseT slot
        ChainDB.ScheduledGC slot _difft ->
          "Scheduled a garbage collection for " <> condenseT slot
      ChainDB.TraceOpenEvent ev -> case ev of
        ChainDB.StartedOpeningDB -> "Started opening Chain DB"
        ChainDB.StartedOpeningImmutableDB -> "Started opening Immutable DB"
        ChainDB.StartedOpeningVolatileDB -> "Started opening Volatile DB"
        ChainDB.StartedOpeningLgrDB -> "Started opening Ledger DB"
        ChainDB.OpenedDB immTip tip' ->
          "Opened db with immutable tip at " <> renderPointAsPhrase immTip <>
          " and tip " <> renderPointAsPhrase tip'
        ChainDB.ClosedDB immTip tip' ->
          "Closed db with immutable tip at " <> renderPointAsPhrase immTip <>
          " and tip " <> renderPointAsPhrase tip'
        ChainDB.OpenedImmutableDB immTip chunk ->
          "Opened imm db with immutable tip at " <> renderPointAsPhrase immTip <>
          " and chunk " <> showT chunk
        ChainDB.OpenedVolatileDB mx ->  "Opened " <> case mx of
          NoMaxSlotNo -> "empty Volatile DB"
          MaxSlotNo mxx -> "Volatile DB with max slot seen " <> showT mxx
        ChainDB.OpenedLgrDB ->  "Opened lgr db"
      ChainDB.TraceFollowerEvent ev -> case ev of
        ChainDB.NewFollower ->  "New follower was created"
        ChainDB.FollowerNoLongerInMem _ ->  "FollowerNoLongerInMem"
        ChainDB.FollowerSwitchToMem _ _ ->  "FollowerSwitchToMem"
        ChainDB.FollowerNewImmIterator _ _ ->  "FollowerNewImmIterator"
      ChainDB.TraceInitChainSelEvent ev -> case ev of
        ChainDB.StartedInitChainSelection -> "Started initial chain selection"
        ChainDB.InitialChainSelected -> "Initial chain selected"
        ChainDB.InitChainSelValidation e -> case e of
          ChainDB.InvalidBlock _err _pt -> "Invalid block found during Initial chain selection, truncating the candidate and retrying to select a best candidate."
          ChainDB.ValidCandidate af     -> "Valid candidate spanning from " <> renderPointAsPhrase (AF.lastPoint af) <> " to " <> renderPointAsPhrase (AF.headPoint af)
          ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) ->
            let fromSlot = unSlotNo $ realPointSlot start
                atSlot   = unSlotNo $ realPointSlot curr
                atDiff   = atSlot - fromSlot
                toSlot   = unSlotNo $ realPointSlot goal
                toDiff   = toSlot - fromSlot
            in
              "Pushing ledger state for block " <> renderRealPointAsPhrase curr <> ". Progress: " <>
              showProgressT (fromIntegral atDiff) (fromIntegral toDiff) <> "%"
      ChainDB.TraceIteratorEvent ev -> case ev of
        ChainDB.UnknownRangeRequested ev' ->
          case ev' of
            ChainDB.MissingBlock realPt ->
              "The block at the given point was not found in the ChainDB."
              <> renderRealPoint realPt
            ChainDB.ForkTooOld streamFrom ->
              "The requested range forks off too far in the past"
              <> showT streamFrom
        ChainDB.BlockMissingFromVolatileDB realPt -> mconcat
          [ "This block is no longer in the VolatileDB because it has been garbage"
          , " collected. It might now be in the ImmutableDB if it was part of the"
          , " current chain. Block: "
          , renderRealPoint realPt
          ]
        ChainDB.StreamFromImmutableDB sFrom sTo -> mconcat
          [ "Stream only from the ImmutableDB. StreamFrom:"
          , showT sFrom
          , " StreamTo: "
          , showT sTo
          ]
        ChainDB.StreamFromBoth sFrom sTo pts -> mconcat
          [ "Stream from both the VolatileDB and the ImmutableDB."
          , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo
          , " Points: " <> showT (map renderRealPoint pts)
          ]
        ChainDB.StreamFromVolatileDB sFrom sTo pts -> mconcat
          [ "Stream only from the VolatileDB."
          , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo
          , " Points: " <> showT (map renderRealPoint pts)
          ]
        ChainDB.BlockWasCopiedToImmutableDB pt -> mconcat
          [ "This block has been garbage collected from the VolatileDB is now"
          , " found and streamed from the ImmutableDB. Block: " <> renderRealPoint pt
          ]
        ChainDB.BlockGCedFromVolatileDB pt -> mconcat
          [ "This block no longer in the VolatileDB and isn't in the ImmutableDB"
          , " either; it wasn't part of the current chain. Block: " <> renderRealPoint pt
          ]
        ChainDB.SwitchBackToVolatileDB ->  "SwitchBackToVolatileDB"
      ChainDB.TraceImmutableDBEvent ev -> case ev of
        ImmDB.NoValidLastLocation ->
          "No valid last location was found. Starting from Genesis."
        ImmDB.ValidatedLastLocation cn t ->
            "Found a valid last location at chunk "
          <> showT cn
          <> " with tip "
          <> renderRealPoint (ImmDB.tipToRealPoint t)
          <> "."
        ImmDB.ChunkValidationEvent e -> case e of
          ImmDB.StartedValidatingChunk chunkNo outOf ->
               "Validating chunk no. " <> showT chunkNo <> " out of " <> showT outOf
            <> ". Progress: " <> showProgressT (chunkNoToInt chunkNo) (chunkNoToInt outOf + 1) <> "%"
          ImmDB.ValidatedChunk chunkNo outOf ->
               "Validated chunk no. " <> showT chunkNo <> " out of " <> showT outOf
            <> ". Progress: " <> showProgressT (chunkNoToInt chunkNo + 1) (chunkNoToInt outOf + 1) <> "%"
          ImmDB.MissingChunkFile cn      ->
            "The chunk file with number " <> showT cn <> " is missing."
          ImmDB.InvalidChunkFile cn er    ->
            "The chunk file with number " <> showT cn <> " is invalid: " <> showT er
          ImmDB.MissingPrimaryIndex cn   ->
            "The primary index of the chunk file with number " <> showT cn <> " is missing."
          ImmDB.MissingSecondaryIndex cn ->
            "The secondary index of the chunk file with number " <> showT cn <> " is missing."
          ImmDB.InvalidPrimaryIndex cn   ->
            "The primary index of the chunk file with number " <> showT cn <> " is invalid."
          ImmDB.InvalidSecondaryIndex cn ->
            "The secondary index of the chunk file with number " <> showT cn <> " is invalid."
          ImmDB.RewritePrimaryIndex cn   ->
            "Rewriting the primary index for the chunk file with number " <> showT cn <> "."
          ImmDB.RewriteSecondaryIndex cn ->
            "Rewriting the secondary index for the chunk file with number " <> showT cn <> "."
        ImmDB.ChunkFileDoesntFit ch1 ch2 ->
          "Chunk file doesn't fit. The hash of the block " <> showT ch2 <> " doesn't match the previous hash of the first block in the current epoch: " <> showT ch1 <> "."
        ImmDB.Migrating t -> "Migrating: " <> t
        ImmDB.DeletingAfter wot -> "Deleting chunk files after " <> showT wot
        ImmDB.DBAlreadyClosed {} -> "Immutable DB was already closed. Double closing."
        ImmDB.DBClosed {} -> "Closed Immutable DB."
        ImmDB.TraceCacheEvent ev' -> "Cache event: " <> case ev' of
          ImmDB.TraceCurrentChunkHit   cn   curr -> "Current chunk hit: " <> showT cn <> ", cache size: " <> showT curr
          ImmDB.TracePastChunkHit      cn   curr -> "Past chunk hit: " <> showT cn <> ", cache size: " <> showT curr
          ImmDB.TracePastChunkMiss     cn   curr -> "Past chunk miss: " <> showT cn <> ", cache size: " <> showT curr
          ImmDB.TracePastChunkEvict    cn   curr -> "Past chunk evict: " <> showT cn <> ", cache size: " <> showT curr
          ImmDB.TracePastChunksExpired cns  curr -> "Past chunks expired: " <> showT cns <> ", cache size: " <> showT curr
      ChainDB.TraceVolatileDBEvent ev -> case ev of
        VolDb.DBAlreadyClosed       -> "Volatile DB was already closed. Double closing."
        VolDb.BlockAlreadyHere bh   -> "Block " <> showT bh <> " was already in the Volatile DB."
        VolDb.Truncate e pth offs   -> "Truncating the file at " <> showT pth <> " at offset " <> showT offs <> ": " <> showT e
        VolDb.InvalidFileNames fs   -> "Invalid Volatile DB files: " <> showT fs
        VolDb.DBClosed              -> "Closed Volatile DB."
      ChainDB.TraceChainSelStarvationEvent ev -> case ev of
        ChainDB.ChainSelStarvation RisingEdge -> "Chain Selection was starved."
        ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> "Chain Selection was unstarved by " <> renderRealPoint pt
     where showProgressT :: Int -> Int -> Text
           showProgressT chunkNo outOf =
             pack (showFFloat (Just 2) (100 * fromIntegral chunkNo / fromIntegral outOf :: Float) mempty)

--
-- | instances of @ToObject@
--
-- NOTE: this list is sorted by the unqualified name of the outermost type.

instance ToObject BFT.BftValidationErr where
  toObject _verb (BFT.BftInvalidSignature err) =
    mconcat
      [ "kind" .= String "BftInvalidSignature"
      , "error" .= String (pack err)
      ]


instance ToObject LedgerDB.DiskSnapshot where
  toObject MinimalVerbosity snap = toObject NormalVerbosity snap
  toObject NormalVerbosity _ = mconcat [ "kind" .= String "snapshot" ]
  toObject MaximalVerbosity snap =
    mconcat [ "kind" .= String "snapshot"
             , "snapshot" .= String (pack $ show snap) ]


instance ( StandardHash blk
         , ToObject (LedgerError blk)
         , ToObject (OtherHeaderEnvelopeError blk)
         , ToObject (ValidationErr (BlockProtocol blk)))
      => ToObject (ExtValidationError blk) where
  toObject verb (ExtValidationErrorLedger err) = toObject verb err
  toObject verb (ExtValidationErrorHeader err) = toObject verb err


instance ( StandardHash blk
         , ToObject (OtherHeaderEnvelopeError blk)
         )
      => ToObject (HeaderEnvelopeError blk) where
  toObject _verb (UnexpectedBlockNo expect act) =
    mconcat
      [ "kind" .= String "UnexpectedBlockNo"
      , "expected" .= condense expect
      , "actual" .= condense act
      ]
  toObject _verb (UnexpectedSlotNo expect act) =
    mconcat
      [ "kind" .= String "UnexpectedSlotNo"
      , "expected" .= condense expect
      , "actual" .= condense act
      ]
  toObject _verb (UnexpectedPrevHash expect act) =
    mconcat
      [ "kind" .= String "UnexpectedPrevHash"
      , "expected" .= String (pack $ show expect)
      , "actual" .= String (pack $ show act)
      ]
  toObject _verb (CheckpointMismatch blockNumber hdrHashExpected hdrHashActual) =
    mconcat
      [ "kind" .= String "CheckpointMismatch"
      , "blockNo" .= String (pack $ show blockNumber)
      , "expected" .= String (pack $ show hdrHashExpected)
      , "actual" .= String (pack $ show hdrHashActual)
      ]
  toObject verb (OtherHeaderEnvelopeError err) =
    toObject verb err


instance ( StandardHash blk
         , ToObject (ValidationErr (BlockProtocol blk))
         , ToObject (OtherHeaderEnvelopeError blk)
         )
      => ToObject (HeaderError blk) where
  toObject verb (HeaderProtocolError err) =
    mconcat
      [ "kind" .= String "HeaderProtocolError"
      , "error" .= toObject verb err
      ]
  toObject verb (HeaderEnvelopeError err) =
    mconcat
      [ "kind" .= String "HeaderEnvelopeError"
      , "error" .= toObject verb err
      ]


instance (Show (PBFT.PBftVerKeyHash c))
      => ToObject (PBFT.PBftValidationErr c) where
  toObject _verb (PBFT.PBftInvalidSignature text) =
    mconcat
      [ "kind" .= String "PBftInvalidSignature"
      , "error" .= String text
      ]
  toObject _verb (PBFT.PBftNotGenesisDelegate vkhash _ledgerView) =
    mconcat
      [ "kind" .= String "PBftNotGenesisDelegate"
      , "vk" .= String (pack $ show vkhash)
      ]
  toObject _verb (PBFT.PBftExceededSignThreshold vkhash numForged) =
    mconcat
      [ "kind" .= String "PBftExceededSignThreshold"
      , "vk" .= String (pack $ show vkhash)
      , "numForged" .= String (pack (show numForged))
      ]
  toObject _verb PBFT.PBftInvalidSlot =
    mconcat
      [ "kind" .= String "PBftInvalidSlot"
      ]


instance (Show (PBFT.PBftVerKeyHash c))
      => ToObject (PBFT.PBftCannotForge c) where
  toObject _verb (PBFT.PBftCannotForgeInvalidDelegation vkhash) =
    mconcat
      [ "kind" .= String "PBftCannotForgeInvalidDelegation"
      , "vk" .= String (pack $ show vkhash)
      ]
  toObject _verb (PBFT.PBftCannotForgeThresholdExceeded numForged) =
    mconcat
      [ "kind" .= String "PBftCannotForgeThresholdExceeded"
      , "numForged" .= numForged
      ]


instance ConvertRawHash blk
      => ToObject (RealPoint blk) where
  toObject verb p = mconcat
        [ "kind" .= String "Point"
        , "slot" .= unSlotNo (realPointSlot p)
        , "hash" .= renderHeaderHashForVerbosity (Proxy @blk) verb (realPointHash p) ]


instance (ToObject (LedgerUpdate blk), ToObject (LedgerWarning blk))
      => ToObject (LedgerEvent blk) where
  toObject verb = \case
    LedgerUpdate  update  -> toObject verb update
    LedgerWarning warning -> toObject verb warning


instance ( ConvertRawHash blk
         , LedgerSupportsProtocol blk
         , ToObject (Header blk)
         , ToObject (LedgerEvent blk)
         , ToObject (SelectView (BlockProtocol blk)))
      => ToObject (ChainDB.TraceEvent blk) where
  toObject _verb ChainDB.TraceLastShutdownUnclean =
    mconcat [ "kind" .= String "TraceLastShutdownUnclean" ]
  toObject verb (ChainDB.TraceAddBlockEvent ev) = case ev of
    ChainDB.IgnoreBlockOlderThanImmTip pt ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.IgnoreBlockOlderThanImmTip"
               , "block" .= toObject verb pt ]
    ChainDB.IgnoreBlockAlreadyInVolatileDB pt ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.IgnoreBlockAlreadyInVolatileDB"
               , "block" .= toObject verb pt ]
    ChainDB.IgnoreInvalidBlock pt reason ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.IgnoreInvalidBlock"
               , "block" .= toObject verb pt
               , "reason" .= show reason ]
    ChainDB.AddedBlockToQueue pt edgeSz ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.AddedBlockToQueue"
               , "block" .= toObject verb pt
               , case edgeSz of
                   RisingEdge         -> "risingEdge" .= True
                   FallingEdgeWith sz -> "queueSize" .= toJSON sz ]
    ChainDB.PoppingFromQueue ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.PoppingFromQueue"
              ]
    ChainDB.PoppedBlockFromQueue pt ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.PoppedBlockFromQueue"
              , "block" .= toObject verb pt
              ]
    ChainDB.StoreButDontChange pt ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.StoreButDontChange"
               , "block" .= toObject verb pt ]
    ChainDB.TryAddToCurrentChain pt ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.TryAddToCurrentChain"
               , "block" .= toObject verb pt ]
    ChainDB.TrySwitchToAFork pt _ ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.TrySwitchToAFork"
               , "block" .= toObject verb pt ]
    ChainDB.ChangingSelection pt ->
      mconcat [ "kind" .= String "TraceAddBlockEvent.ChangingSelection"
               , "block" .= toObject verb pt ]
    ChainDB.AddedToCurrentChain events selChangedInfo base extended ->
      mconcat $
               [ "kind" .= String "TraceAddBlockEvent.AddedToCurrentChain"
               , "newtip" .= renderPointForVerbosity verb (AF.headPoint extended)
               , "chainLengthDelta" .= extended `chainLengthΔ` base
               , "newTipSelectView" .= toObject verb (ChainDB.newTipSelectView selChangedInfo)
               ]
            ++ [ "oldTipSelectView" .= toObject verb oldTipSelectView
               | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo]
               ]
            ++ [ "headers" .= toJSON (toObject verb `map` addedHdrsNewChain base extended)
               | verb == MaximalVerbosity ]
            ++ [ "events" .= toJSON (map (toObject verb) events)
               | not (null events) ]
    ChainDB.SwitchedToAFork events selChangedInfo old new ->
      mconcat $
               [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork"
               , "newtip" .= renderPointForVerbosity verb (AF.headPoint new)
               , "chainLengthDelta" .= new `chainLengthΔ` old
               -- Check that the SwitchedToAFork event was triggered by a proper fork.
               , "realFork" .= not (AF.withinFragmentBounds (AF.headPoint old) new)
               , "newTipSelectView" .= toObject verb (ChainDB.newTipSelectView selChangedInfo)
               ]
            ++ [ "oldTipSelectView" .= toObject verb oldTipSelectView
               | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo]
               ]
            ++ [ "headers" .= toJSON (toObject verb `map` addedHdrsNewChain old new)
               | verb == MaximalVerbosity ]
            ++ [ "events" .= toJSON (map (toObject verb) events)
               | not (null events) ]
    ChainDB.AddBlockValidation ev' -> case ev' of
      ChainDB.InvalidBlock err pt ->
        mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.InvalidBlock"
                 , "block" .= toObject verb pt
                 , "error" .= show err ]
      ChainDB.ValidCandidate c ->
        mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.ValidCandidate"
                 , "block" .= renderPointForVerbosity verb (AF.headPoint c) ]
      ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) ->
        mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.UpdateLedgerDb"
                 , "startingBlock" .= renderRealPoint start
                 , "currentBlock" .= renderRealPoint curr
                 , "targetBlock" .= renderRealPoint goal
                 ]
    ChainDB.AddedBlockToVolatileDB pt (BlockNo bn) _isEBB enclosing ->
      mconcat $ [ "kind" .= String "TraceAddBlockEvent.AddedBlockToVolatileDB"
                , "block" .= toObject verb pt
                , "blockNo" .= show bn ]
                <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ]
    ChainDB.PipeliningEvent ev' -> case ev' of
      ChainDB.SetTentativeHeader hdr enclosing ->
        mconcat $ [ "kind" .= String "TraceAddBlockEvent.PipeliningEvent.SetTentativeHeader"
                  , "block" .= renderPointForVerbosity verb (blockPoint hdr)
                  ]
                  <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ]
      ChainDB.TrapTentativeHeader hdr ->
        mconcat [ "kind" .= String "TraceAddBlockEvent.PipeliningEvent.TrapTentativeHeader"
                 , "block" .= renderPointForVerbosity verb (blockPoint hdr)
                 ]
      ChainDB.OutdatedTentativeHeader hdr ->
        mconcat [ "kind" .= String "TraceAddBlockEvent.PipeliningEvent.OutdatedTentativeHeader"
                 , "block" .= renderPointForVerbosity verb (blockPoint hdr)
                 ]
    ChainDB.AddedReprocessLoEBlocksToQueue RisingEdge ->
       mconcat [ "kind" .= String "AddedReprocessLoEBlocksToQueue" ]
    ChainDB.AddedReprocessLoEBlocksToQueue (FallingEdgeWith _) ->
       mconcat [ "kind" .= String "AddedReprocessLoEBlocksToQueue TODO" ]
    ChainDB.PoppedReprocessLoEBlocksFromQueue ->
       mconcat [ "kind" .= String "PoppedReprocessLoEBlocksFromQueue" ]
    ChainDB.ChainSelectionLoEDebug curChain loeFrag ->
      case loeFrag of
        ChainDB.LoEEnabled loeF ->
          mconcat [ "kind" .= String "ChainSelectionLoEDebug"
                  , "curChain" .= headAndAnchor curChain
                  , "loeFrag" .= headAndAnchor loeF
                  ]
        ChainDB.LoEDisabled ->
          mconcat [ "kind" .= String "ChainSelectionLoEDebug"
                  , "curChain" .= headAndAnchor curChain
                  , "loeFrag" .= String "LoE is disabled"
                  ]
      where
        headAndAnchor frag = Aeson.object
          [ "anchor" .= renderPointForVerbosity verb (AF.anchorPoint frag)
          , "head" .= renderPointForVerbosity verb (AF.headPoint frag)
          ]
   where
     addedHdrsNewChain
       :: AF.AnchoredFragment (Header blk)
       -> AF.AnchoredFragment (Header blk)
       -> [Header blk]
     addedHdrsNewChain fro to_ =
       case AF.intersect fro to_ of
         Just (_, _, _, s2 :: AF.AnchoredFragment (Header blk)) ->
           AF.toOldestFirst s2
         Nothing -> [] -- No sense to do validation here.
     chainLengthΔ :: AF.AnchoredFragment (Header blk) -> AF.AnchoredFragment (Header blk) -> Int
     chainLengthΔ = on (-) (fromWithOrigin (-1) . fmap (fromIntegral . unBlockNo) . AF.headBlockNo)

  toObject MinimalVerbosity (ChainDB.TraceLedgerDBEvent _ev) = mempty -- no output
  toObject verb (ChainDB.TraceLedgerDBEvent ev) = case ev of
    LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of
      LedgerDB.TookSnapshot snap pt enclosedTiming ->
        mconcat [ "kind" .= String "TraceSnapshotEvent.TookSnapshot"
                 , "snapshot" .= toObject verb snap
                 , "tip" .= show pt
                 , "enclosedTime" .= enclosedTiming
                 ]
      LedgerDB.DeletedSnapshot snap ->
        mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.DeletedSnapshot"
                 , "snapshot" .= toObject verb snap ]
      LedgerDB.InvalidSnapshot snap failure ->
        mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.InvalidSnapshot"
                 , "snapshot" .= toObject verb snap
                 , "failure" .= show failure ]
    LedgerDB.LedgerReplayEvent ev' -> case ev' of
      LedgerDB.TraceReplayStartEvent ev'' -> case ev'' of
        LedgerDB.ReplayFromGenesis ->
          mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayFromGenesis" ]
        LedgerDB.ReplayFromSnapshot snap tip' ->
          mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayFromSnapshot"
                  , "snapshot" .= toObject verb snap
                  , "tip" .= show tip' ]
      LedgerDB.TraceReplayProgressEvent (LedgerDB.ReplayedBlock pt _ledgerEvents _ (LedgerDB.ReplayGoal replayTo)) ->
        mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayedBlock"
                , "slot" .= unSlotNo (realPointSlot pt)
                , "tip"  .= withOrigin 0 unSlotNo (pointSlot replayTo) ]
    LedgerDB.LedgerDBForkerEvent (LedgerDB.TraceForkerEventWithKey k ev') ->
      mconcat [ "kind" .= String "LedgerDBForkerEvent"
              , "key" .= show k
              , "event" .= show ev' ]
    LedgerDB.LedgerDBFlavorImplEvent ev' ->
      mconcat [ "kind" .= String "LedgerDBFlavorImplEvent"
              , "event" .= show ev' ]

  toObject verb (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of
    ChainDB.CopiedBlockToImmutableDB pt ->
      mconcat [ "kind" .= String "TraceCopyToImmutableDBEvent.CopiedBlockToImmutableDB"
               , "slot" .= toObject verb pt ]
    ChainDB.NoBlocksToCopyToImmutableDB ->
      mconcat [ "kind" .= String "TraceCopyToImmutableDBEvent.NoBlocksToCopyToImmutableDB" ]

  toObject verb (ChainDB.TraceGCEvent ev) = case ev of
    ChainDB.PerformedGC slot ->
      mconcat [ "kind" .= String "TraceGCEvent.PerformedGC"
               , "slot" .= toObject verb slot ]
    ChainDB.ScheduledGC slot difft ->
      mconcat $ [ "kind" .= String "TraceGCEvent.ScheduledGC"
                 , "slot" .= toObject verb slot ] <>
                 [ "difft" .= String ((pack . show) difft) | verb >= MaximalVerbosity]

  toObject verb (ChainDB.TraceOpenEvent ev) = case ev of
    ChainDB.StartedOpeningDB ->
      mconcat ["kind" .= String "TraceOpenEvent.StartedOpeningDB"]
    ChainDB.StartedOpeningImmutableDB ->
      mconcat ["kind" .= String "TraceOpenEvent.StartedOpeningImmutableDB"]
    ChainDB.StartedOpeningVolatileDB ->
      mconcat ["kind" .= String "TraceOpenEvent.StartedOpeningVolatileDB"]
    ChainDB.StartedOpeningLgrDB ->
      mconcat ["kind" .= String "TraceOpenEvent.StartedOpeningLgrDB"]
    ChainDB.OpenedDB immTip tip' ->
      mconcat [ "kind" .= String "TraceOpenEvent.OpenedDB"
               , "immtip" .= toObject verb immTip
               , "tip" .= toObject verb tip' ]
    ChainDB.ClosedDB immTip tip' ->
      mconcat [ "kind" .= String "TraceOpenEvent.ClosedDB"
               , "immtip" .= toObject verb immTip
               , "tip" .= toObject verb tip' ]
    ChainDB.OpenedImmutableDB immTip epoch ->
      mconcat [ "kind" .= String "TraceOpenEvent.OpenedImmutableDB"
               , "immtip" .= toObject verb immTip
               , "epoch" .= String ((pack . show) epoch) ]
    ChainDB.OpenedVolatileDB maxSlotN ->
      mconcat [ "kind" .= String "TraceOpenEvent.OpenedVolatileDB"
               , "maxSlotNo" .= String (showT maxSlotN) ]
    ChainDB.OpenedLgrDB ->
      mconcat [ "kind" .= String "TraceOpenEvent.OpenedLgrDB" ]

  toObject _verb (ChainDB.TraceFollowerEvent ev) = case ev of
    ChainDB.NewFollower ->
      mconcat [ "kind" .= String "TraceFollowerEvent.NewFollower" ]
    ChainDB.FollowerNoLongerInMem _ ->
      mconcat [ "kind" .= String "TraceFollowerEvent.FollowerNoLongerInMem" ]
    ChainDB.FollowerSwitchToMem _ _ ->
      mconcat [ "kind" .= String "TraceFollowerEvent.FollowerSwitchToMem" ]
    ChainDB.FollowerNewImmIterator _ _ ->
      mconcat [ "kind" .= String "TraceFollowerEvent.FollowerNewImmIterator" ]
  toObject verb (ChainDB.TraceInitChainSelEvent ev) = case ev of
    ChainDB.InitialChainSelected ->
      mconcat ["kind" .= String "TraceFollowerEvent.InitialChainSelected"]
    ChainDB.StartedInitChainSelection ->
      mconcat ["kind" .= String "TraceFollowerEvent.StartedInitChainSelection"]
    ChainDB.InitChainSelValidation ev' -> case ev' of
      ChainDB.InvalidBlock err pt ->
         mconcat [ "kind" .= String "TraceInitChainSelEvent.InvalidBlock"
                  , "block" .= toObject verb pt
                  , "error" .= show err ]
      ChainDB.ValidCandidate c ->
        mconcat [ "kind" .= String "TraceInitChainSelEvent.ValidCandidate"
                 , "block" .= renderPointForVerbosity verb (AF.headPoint c) ]
      ChainDB.UpdateLedgerDbTraceEvent
        (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr) ) ->
          mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.UpdateLedgerDbTraceEvent.StartedPushingBlockToTheLedgerDb"
                   , "startingBlock" .= renderRealPoint start
                   , "currentBlock" .= renderRealPoint curr
                   , "targetBlock" .= renderRealPoint goal
                   ]

  toObject _verb (ChainDB.TraceIteratorEvent ev) = case ev of
    ChainDB.UnknownRangeRequested unkRange ->
      mconcat [ "kind" .= String "TraceIteratorEvent.UnknownRangeRequested"
               , "range" .= String (showT unkRange)
               ]
    ChainDB.StreamFromVolatileDB streamFrom streamTo realPt ->
      mconcat [ "kind" .= String "TraceIteratorEvent.StreamFromVolatileDB"
               , "from" .= String (showT streamFrom)
               , "to" .= String (showT streamTo)
               , "point" .= String (Text.pack . show $ map renderRealPoint realPt)
               ]
    ChainDB.StreamFromImmutableDB streamFrom streamTo ->
      mconcat [ "kind" .= String "TraceIteratorEvent.StreamFromImmutableDB"
               , "from" .= String (showT streamFrom)
               , "to" .= String (showT streamTo)
               ]
    ChainDB.StreamFromBoth streamFrom streamTo realPt ->
      mconcat [ "kind" .= String "TraceIteratorEvent.StreamFromBoth"
               , "from" .= String (showT streamFrom)
               , "to" .= String (showT streamTo)
               , "point" .= String (Text.pack . show $ map renderRealPoint realPt)
               ]
    ChainDB.BlockMissingFromVolatileDB realPt ->
      mconcat [ "kind" .= String "TraceIteratorEvent.BlockMissingFromVolatileDB"
               , "point" .= String (renderRealPoint realPt)
               ]
    ChainDB.BlockWasCopiedToImmutableDB realPt ->
      mconcat [ "kind" .= String "TraceIteratorEvent.BlockWasCopiedToImmutableDB"
               , "point" .= String (renderRealPoint realPt)
               ]
    ChainDB.BlockGCedFromVolatileDB realPt ->
      mconcat [ "kind" .= String "TraceIteratorEvent.BlockGCedFromVolatileDB"
               , "point" .= String (renderRealPoint realPt)
               ]
    ChainDB.SwitchBackToVolatileDB ->
      mconcat ["kind" .= String "TraceIteratorEvent.SwitchBackToVolatileDB"
               ]
  toObject verb (ChainDB.TraceImmutableDBEvent ev) = case ev of
    ImmDB.ChunkValidationEvent traceChunkValidation -> toObject verb traceChunkValidation
    ImmDB.NoValidLastLocation ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.NoValidLastLocation" ]
    ImmDB.ValidatedLastLocation chunkNo immTip ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.ValidatedLastLocation"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               , "immTip" .= String (renderTipHash immTip)
               , "blockNo" .= String (renderTipBlockNo immTip)
               ]
    ImmDB.ChunkFileDoesntFit expectPrevHash actualPrevHash ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.ChunkFileDoesntFit"
               , "expectedPrevHash" .= String (renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) expectPrevHash)
               , "actualPrevHash" .= String (renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) actualPrevHash)
               ]
    ImmDB.Migrating txt ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.Migrating"
               , "info" .= String txt
               ]
    ImmDB.DeletingAfter immTipWithInfo ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.DeletingAfter"
               , "immTipHash" .= String (renderWithOrigin renderTipHash immTipWithInfo)
               , "immTipBlockNo" .= String (renderWithOrigin renderTipBlockNo immTipWithInfo)
               ]
    ImmDB.DBAlreadyClosed -> mconcat [ "kind" .= String "TraceImmutableDBEvent.DBAlreadyClosed" ]
    ImmDB.DBClosed -> mconcat [ "kind" .= String "TraceImmutableDBEvent.DBClosed" ]
    ImmDB.TraceCacheEvent cacheEv ->
      case cacheEv of
        ImmDB.TraceCurrentChunkHit chunkNo nbPastChunksInCache ->
          mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TraceCurrentChunkHit"
                   , "chunkNo" .= String (renderChunkNo chunkNo)
                   , "noPastChunks" .= String (showT nbPastChunksInCache)
                   ]
        ImmDB.TracePastChunkHit chunkNo nbPastChunksInCache ->
          mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TracePastChunkHit"
                   , "chunkNo" .= String (renderChunkNo chunkNo)
                   , "noPastChunks" .= String (showT nbPastChunksInCache)
                   ]
        ImmDB.TracePastChunkMiss chunkNo nbPastChunksInCache ->
          mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TracePastChunkMiss"
                   , "chunkNo" .= String (renderChunkNo chunkNo)
                   , "noPastChunks" .= String (showT nbPastChunksInCache)
                   ]
        ImmDB.TracePastChunkEvict chunkNo nbPastChunksInCache ->
          mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TracePastChunkEvict"
                   , "chunkNo" .= String (renderChunkNo chunkNo)
                   , "noPastChunks" .= String (showT nbPastChunksInCache)
                   ]
        ImmDB.TracePastChunksExpired chunkNos nbPastChunksInCache ->
          mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TracePastChunksExpired"
                   , "chunkNos" .= String (Text.pack . show $ map renderChunkNo chunkNos)
                   , "noPastChunks" .= String (showT nbPastChunksInCache)
                   ]
  toObject _verb (ChainDB.TraceVolatileDBEvent ev) = case ev of
    VolDb.DBAlreadyClosed -> mconcat [ "kind" .= String "TraceVolatileDbEvent.DBAlreadyClosed"]
    VolDb.BlockAlreadyHere blockId ->
      mconcat [ "kind" .= String "TraceVolatileDbEvent.BlockAlreadyHere"
               , "blockId" .= String (showT blockId)
               ]
    VolDb.Truncate pErr fsPath blockOffset ->
      mconcat [ "kind" .= String "TraceVolatileDbEvent.Truncate"
               , "parserError" .= String (showT pErr)
               , "file" .= String (showT fsPath)
               , "blockOffset" .= String (showT blockOffset)
               ]
    VolDb.InvalidFileNames fsPaths ->
      mconcat [ "kind" .= String "TraceVolatileDBEvent.InvalidFileNames"
               , "files" .= String (Text.pack . show $ map show fsPaths)
               ]
    VolDb.DBClosed -> mconcat [ "kind" .= String "TraceVolatileDbEvent.DBClosed"]
  toObject verb (ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation edge)) =
     mconcat [ "kind" .= String "ChainDB.ChainSelStarvation"
             , case edge of
                 RisingEdge -> "risingEdge" .= True
                 FallingEdgeWith pt -> "fallingEdge" .= toObject verb pt
             ]

instance ConvertRawHash blk => ToObject (ImmDB.TraceChunkValidation blk ChunkNo) where
  toObject verb ev = case ev of
    ImmDB.RewriteSecondaryIndex chunkNo ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.RewriteSecondaryIndex"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               ]
    ImmDB.RewritePrimaryIndex chunkNo ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.RewritePrimaryIndex"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               ]
    ImmDB.MissingPrimaryIndex chunkNo ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.MissingPrimaryIndex"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               ]
    ImmDB.MissingSecondaryIndex chunkNo ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.MissingSecondaryIndex"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               ]
    ImmDB.InvalidPrimaryIndex chunkNo ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidPrimaryIndex"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               ]
    ImmDB.InvalidSecondaryIndex chunkNo ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidSecondaryIndex"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               ]
    ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrHashMismatch hashPrevBlock prevHashOfBlock) ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrHashMismatch"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               , "hashPrevBlock" .= String (Text.decodeLatin1 . toRawHash (Proxy @blk) $ hashPrevBlock)
               , "prevHashOfBlock" .= String (renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) prevHashOfBlock)
               ]
    ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrCorrupt pt) ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrCorrupt"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               , "block" .= String (renderPointForVerbosity verb pt)
               ]
    ImmDB.ValidatedChunk chunkNo _ ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.ValidatedChunk"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               ]
    ImmDB.MissingChunkFile chunkNo ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.MissingChunkFile"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               ]
    ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrRead readIncErr) ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrRead"
               , "chunkNo" .= String (renderChunkNo chunkNo)
               , "error" .= String (showT readIncErr)
               ]
    ImmDB.StartedValidatingChunk initialChunk finalChunk ->
      mconcat [ "kind" .= String "TraceImmutableDBEvent.StartedValidatingChunk"
               , "initialChunk" .= renderChunkNo initialChunk
               , "finalChunk" .= renderChunkNo finalChunk
               ]


instance ConvertRawHash blk => ToObject (TraceBlockFetchServerEvent blk) where
  toObject _verb (TraceBlockFetchServerSendBlock blk) =
    mconcat [ "kind"  .= String "TraceBlockFetchServerSendBlock"
             , "block" .= String (renderChainHash @blk (renderHeaderHash (Proxy @blk)) $ pointHash blk)
             ]

tipToObject :: forall blk. ConvertRawHash blk => Tip blk -> Aeson.Object
tipToObject = \case
  TipGenesis -> mconcat
    [ "slot"    .= toJSON (0 :: Int)
    , "block"   .= String "genesis"
    , "blockNo" .= toJSON ((-1) :: Int)
    ]
  Tip slot hash blockno -> mconcat
    [ "slot"    .= slot
    , "block"   .= String (renderHeaderHash (Proxy @blk) hash)
    , "blockNo" .= blockno
    ]

instance (ConvertRawHash blk, LedgerSupportsProtocol blk)
      => ToObject (TraceChainSyncClientEvent blk) where
  toObject verb ev = case ev of
    TraceDownloadedHeader h ->
      mconcat
               [ "kind" .= String "ChainSyncClientEvent.TraceDownloadedHeader"
               , tipToObject (tipFromHeader h)
               ]
    TraceRolledBack tip ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceRolledBack"
               , "tip" .= toObject verb tip ]
    TraceException exc ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceException"
               , "exception" .= String (pack $ show exc) ]
    TraceFoundIntersection _ _ _ ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceFoundIntersection" ]
    TraceTermination reason ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceTermination"
               , "reason" .= String (pack $ show reason) ]
    TraceValidatedHeader h ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceValidatedHeader"
              , tipToObject (tipFromHeader h) ]
    TraceWaitingBeyondForecastHorizon slotNo ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceWaitingBeyondForecastHorizon"
               , "slot" .= condense slotNo  ]
    TraceAccessingForecastHorizon slotNo ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceAccessingForecastHorizon"
               , "slot" .= condense slotNo  ]
    TraceGaveLoPToken tokenGiven h bestBlockNumberPriorToH ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceGaveLoPToken"
               , "given" .= tokenGiven
               , tipToObject (tipFromHeader h)
               , "blockNo" .=  bestBlockNumberPriorToH ]
    TraceOfferJump jumpTo ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceOfferJump"
               , "jumpTo" .= toObject verb jumpTo
               ]
    TraceJumpResult res ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceJumpResult"
               , "res" .= case res of
                   ChainSync.Client.AcceptedJump info -> Aeson.object
                     [ "kind" .= String "AcceptedJump"
                      , "payload" .= toObject verb info ]
                   ChainSync.Client.RejectedJump info -> Aeson.object
                     [ "kind" .= String "RejectedJump"
                      , "payload" .= toObject verb info ]
               ]
    TraceJumpingWaitingForNextInstruction ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceJumpingWaitingForNextInstruction"
               ]
    TraceJumpingInstructionIs instr ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceJumpingInstructionIs"
               , "instr" .= toObject verb instr
               ]
    TraceDrainingThePipe n ->
      mconcat [ "kind" .= String "ChainSyncClientEvent.TraceDrainingThePipe"
               , "n" .= natToInt n
               ]

instance ( LedgerSupportsProtocol blk,
           ConvertRawHash blk
         ) => ToObject (ChainSync.Client.Instruction blk) where
  toObject verb = \case
    ChainSync.Client.RunNormally ->
      mconcat ["kind" .= String "RunNormally"]
    ChainSync.Client.Restart ->
      mconcat ["kind" .= String "Restart"]
    ChainSync.Client.JumpInstruction info ->
      mconcat [ "kind" .= String "JumpInstruction"
              , "payload" .= toObject verb info
              ]

instance ( LedgerSupportsProtocol blk,
           ConvertRawHash blk
         ) => ToObject (ChainSync.Client.JumpInstruction blk) where
  toObject verb = \case
    ChainSync.Client.JumpTo info ->
      mconcat [ "kind" .= String "JumpTo"
                , "info" .= toObject verb info ]
    ChainSync.Client.JumpToGoodPoint info ->
      mconcat [ "kind" .= String "JumpToGoodPoint"
                , "info" .= toObject verb info ]

instance ( LedgerSupportsProtocol blk,
           ConvertRawHash blk
         ) => ToObject (ChainSync.Client.JumpInfo blk) where
  toObject verb info =
    mconcat [ "kind" .= String "JumpInfo"
              , "mostRecentIntersection" .= toObject verb (ChainSync.Client.jMostRecentIntersection info)
              , "ourFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jOurFragment info))
              , "theirFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jTheirFragment info))
              ]

instance HasPrivacyAnnotation (ChainSync.Client.TraceEventCsj peer blk) where
instance HasSeverityAnnotation (ChainSync.Client.TraceEventCsj peer blk) where
  getSeverityAnnotation _ = Debug
instance (ToObject peer, ConvertRawHash blk)
      => Transformable Text IO (TraceLabelPeer peer (ChainSync.Client.TraceEventCsj peer blk)) where
  trTransformer = trStructured
instance (ToObject peer, ConvertRawHash blk)
      => ToObject (ChainSync.Client.TraceEventCsj peer blk) where
    toObject verb = \case
      ChainSync.Client.BecomingObjector prevObjector ->
        mconcat
          [ "kind" .= String "BecomingObjector"
          , "previousObjector" .= (toObject verb <$> prevObjector)
          ]
      ChainSync.Client.BlockedOnJump ->
        mconcat
          [ "kind" .= String "BlockedOnJump"
          ]
      ChainSync.Client.InitializedAsDynamo ->
        mconcat
          [ "kind" .= String "InitializedAsDynamo"
          ]
      ChainSync.Client.NoLongerDynamo newDynamo reason ->
        mconcat
          [ "kind" .= String "NoLongerDynamo"
          , "newDynamo" .= (toObject verb <$> newDynamo)
          , "reason" .= csjReasonToJSON reason
          ]
      ChainSync.Client.NoLongerObjector newObjector reason ->
        mconcat
          [ "kind" .= String "NoLongerObjector"
          , "newObjector" .= (toObject verb <$> newObjector)
          , "reason" .= csjReasonToJSON reason
          ]
      ChainSync.Client.SentJumpInstruction jumpTarget ->
        mconcat
          [ "kind" .= String "SentJumpInstruction"
          , "jumpTarget" .= toObject verb jumpTarget
          ]
      where
        csjReasonToJSON = \case
          ChainSync.Client.BecauseCsjDisengage -> String "BecauseCsjDisengage"
          ChainSync.Client.BecauseCsjDisconnect -> String "BecauseCsjDisconnect"


instance HasPrivacyAnnotation (ChainSync.Client.TraceEventDbf peer) where
instance HasSeverityAnnotation (ChainSync.Client.TraceEventDbf peer) where
  getSeverityAnnotation _ = Info
instance ToObject peer
      => Transformable Text IO (ChainSync.Client.TraceEventDbf peer) where
  trTransformer = trStructured
instance HasTextFormatter (ChainSync.Client.TraceEventDbf peer) where
instance ToObject peer
      => ToObject (ChainSync.Client.TraceEventDbf peer) where
    toObject verb = \case
      ChainSync.Client.RotatedDynamo oldPeer newPeer ->
        mconcat
          [ "kind" .= String "RotatedDynamo"
          , "oldPeer" .= toObject verb oldPeer
          , "newPeer" .= toObject verb newPeer
          ]

instance ConvertRawHash blk
      => ToObject (TraceChainSyncServerEvent blk) where
  toObject verb ev = case ev of
    TraceChainSyncServerUpdate tip update blocking enclosing ->
      mconcat $
        [ "kind" .= String "ChainSyncServerEvent.TraceChainSyncServerUpdate"
        , "tip" .= tipToObject tip
        , case update of
            AddBlock pt -> "addBlock" .= renderPointForVerbosity verb pt
            RollBack pt -> "rollBackTo" .= renderPointForVerbosity verb pt
        , "blockingRead" .= case blocking of Blocking -> True; NonBlocking -> False
        ]
        <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ]

instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk),
           ToJSON (GenTxId blk), LedgerSupportsMempool blk,
           ConvertRawHash blk
         ) => ToObject (TraceEventMempool blk) where
  toObject verb (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) =
    mconcat
      [ "kind" .= String "TraceMempoolAddedTx"
      , "tx" .= toObject verb (txForgetValidated tx)
      , "mempoolSize" .= toObject verb mpSzAfter
      ]
  toObject verb (TraceMempoolRejectedTx tx txApplyErr mpSz) =
    mconcat $
      [ "kind" .= String "TraceMempoolRejectedTx"
      , "tx" .= toObject verb tx
      , "mempoolSize" .= toObject verb mpSz
      ] <>
      [ "err" .= toObject verb txApplyErr
      | verb == MaximalVerbosity
      ]
  toObject verb (TraceMempoolRemoveTxs txs mpSz) =
    mconcat
      [ "kind" .= String "TraceMempoolRemoveTxs"
      , "txs"
          .= map
            ( \(tx, err) ->
                Aeson.object $
                  [ "tx" .= toObject verb (txForgetValidated tx)
                  ] <>
                  [ "err" .= toObject verb err
                  | verb == MaximalVerbosity
                  ]
            )
            txs
      , "mempoolSize" .= toObject verb mpSz
      ]
  toObject verb (TraceMempoolManuallyRemovedTxs txs0 txs1 mpSz) =
    mconcat
      [ "kind" .= String "TraceMempoolManuallyRemovedTxs"
      , "txsRemoved" .= txs0
      , "txsInvalidated" .= map (toObject verb . txForgetValidated) txs1
      , "mempoolSize" .= toObject verb mpSz
      ]
  toObject _verb (TraceMempoolSynced et) =
    mconcat
      [ "kind" .= String "TraceMempoolSynced"
      , "enclosingTime" .= et
      ]
  toObject verb (TraceMempoolSyncNotNeeded t) =
    mconcat
      [ "kind" .= String "TraceMempoolSyncNotNeeded"
      , "tip" .= toObject verb t
      ]
  toObject verb (TraceMempoolAttemptingAdd tx) =
    mconcat
      [ "kind" .= String "TraceMempoolAttemptingAdd"
      , "tx" .= toObject verb tx
      ]

  toObject _verb TraceMempoolTipMovedBetweenSTMBlocks =
    mconcat
      [ "kind" .= String "TraceMempoolTipMovedBetweenSTMBlocks"
      ]

instance ToObject MempoolSize where
  toObject _verb MempoolSize{msNumTxs, msNumBytes} =
    mconcat
      [ "numTxs" .= msNumTxs
      , "bytes" .= unByteSize32 msNumBytes
      ]

instance HasTextFormatter () where
  formatText _ = pack . show . toList

-- ForgeStateInfo default value = ()
instance Transformable Text IO () where
  trTransformer = trStructuredText

instance ( RunNode blk
         , ToObject (LedgerError blk)
         , ToObject (OtherHeaderEnvelopeError blk)
         , ToObject (ValidationErr (BlockProtocol blk))
         , ToObject (CannotForge blk)
         , ToObject (ForgeStateUpdateError blk))
      => ToObject (TraceForgeEvent blk) where
  toObject _verb (TraceStartLeadershipCheck slotNo) =
    mconcat
      [ "kind" .= String "TraceStartLeadershipCheck"
      , "slot" .= toJSON (unSlotNo slotNo)
      ]
  toObject verb (TraceSlotIsImmutable slotNo tipPoint tipBlkNo) =
    mconcat
      [ "kind" .= String "TraceSlotIsImmutable"
      , "slot" .= toJSON (unSlotNo slotNo)
      , "tip" .= renderPointForVerbosity verb tipPoint
      , "tipBlockNo" .= toJSON (unBlockNo tipBlkNo)
      ]
  toObject _verb (TraceBlockFromFuture currentSlot tip) =
    mconcat
      [ "kind" .= String "TraceBlockFromFuture"
      , "current slot" .= toJSON (unSlotNo currentSlot)
      , "tip" .= toJSON (unSlotNo tip)
      ]
  toObject verb (TraceBlockContext currentSlot tipBlkNo tipPoint) =
    mconcat
      [ "kind" .= String "TraceBlockContext"
      , "current slot" .= toJSON (unSlotNo currentSlot)
      , "tip" .= renderPointForVerbosity verb tipPoint
      , "tipBlockNo" .= toJSON (unBlockNo tipBlkNo)
      ]
  toObject _verb (TraceNoLedgerState slotNo _pt) =
    mconcat
      [ "kind" .= String "TraceNoLedgerState"
      , "slot" .= toJSON (unSlotNo slotNo)
      ]
  toObject _verb (TraceLedgerState slotNo _pt) =
    mconcat
      [ "kind" .= String "TraceLedgerState"
      , "slot" .= toJSON (unSlotNo slotNo)
      ]
  toObject _verb (TraceNoLedgerView slotNo _) =
    mconcat
      [ "kind" .= String "TraceNoLedgerView"
      , "slot" .= toJSON (unSlotNo slotNo)
      ]
  toObject _verb (TraceLedgerView slotNo) =
    mconcat
      [ "kind" .= String "TraceLedgerView"
      , "slot" .= toJSON (unSlotNo slotNo)
      ]
  toObject verb (TraceForgeStateUpdateError slotNo reason) =
    mconcat
      [ "kind" .= String "TraceForgeStateUpdateError"
      , "slot" .= toJSON (unSlotNo slotNo)
      , "reason" .= toObject verb reason
      ]
  toObject verb (TraceNodeCannotForge slotNo reason) =
    mconcat
      [ "kind" .= String "TraceNodeCannotForge"
      , "slot" .= toJSON (unSlotNo slotNo)
      , "reason" .= toObject verb reason
      ]
  toObject _verb (TraceNodeNotLeader slotNo) =
    mconcat
      [ "kind" .= String "TraceNodeNotLeader"
      , "slot" .= toJSON (unSlotNo slotNo)
      ]
  toObject _verb (TraceNodeIsLeader slotNo) =
    mconcat
      [ "kind" .= String "TraceNodeIsLeader"
      , "slot" .= toJSON (unSlotNo slotNo)
      ]
  toObject verb (TraceForgeTickedLedgerState slotNo prevPt) =
    mconcat
      [ "kind" .= String "TraceForgeTickedLedgerState"
      , "slot" .= toJSON (unSlotNo slotNo)
      , "prev" .= renderPointForVerbosity verb prevPt
      ]
  toObject verb (TraceForgingMempoolSnapshot slotNo prevPt mpHash mpSlot) =
    mconcat
      [ "kind"        .= String "TraceForgingMempoolSnapshot"
      , "slot"        .= toJSON (unSlotNo slotNo)
      , "prev"        .= renderPointForVerbosity verb prevPt
      , "mempoolHash" .= String (renderChainHash @blk (renderHeaderHash (Proxy @blk)) mpHash)
      , "mempoolSlot" .= toJSON (unSlotNo mpSlot)
      ]
  toObject _verb (TraceForgedBlock slotNo _ blk _) =
    mconcat
      [ "kind"      .= String "TraceForgedBlock"
      , "slot"      .= toJSON (unSlotNo slotNo)
      , "block"     .= String (renderHeaderHash (Proxy @blk) $ blockHash blk)
      , "blockNo"   .= toJSON (unBlockNo $ blockNo blk)
      , "blockPrev" .= String (renderChainHash @blk (renderHeaderHash (Proxy @blk)) $ blockPrevHash blk)
      ]
  toObject _verb (TraceDidntAdoptBlock slotNo _) =
    mconcat
      [ "kind" .= String "TraceDidntAdoptBlock"
      , "slot" .= toJSON (unSlotNo slotNo)
      ]
  toObject verb (TraceForgedInvalidBlock slotNo _ reason) =
    mconcat
      [ "kind" .= String "TraceForgedInvalidBlock"
      , "slot" .= toJSON (unSlotNo slotNo)
      , "reason" .= toObject verb reason
      ]
  toObject MaximalVerbosity (TraceAdoptedBlock slotNo blk txs) =
    mconcat
      [ "kind" .= String "TraceAdoptedBlock"
      , "slot" .= toJSON (unSlotNo slotNo)
      , "blockHash" .= renderHeaderHashForVerbosity
          (Proxy @blk)
          MaximalVerbosity
          (blockHash blk)
      , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk))
      , "txIds" .= toJSON (map (show . txId . txForgetValidated) txs)
      ]
  toObject verb (TraceAdoptedBlock slotNo blk _txs) =
    mconcat
      [ "kind" .= String "TraceAdoptedBlock"
      , "slot" .= toJSON (unSlotNo slotNo)
      , "blockHash" .= renderHeaderHashForVerbosity
          (Proxy @blk)
          verb
          (blockHash blk)
      , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk))
      ]
  toObject verb (TraceAdoptionThreadDied slotNo blk) =
    mconcat
      [ "kind" .= String "TraceAdoptionThreadDied"
      , "slot" .= toJSON (unSlotNo slotNo)
      , "blockHash" .= renderHeaderHashForVerbosity
          (Proxy @blk)
          verb
          (blockHash blk)
      , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk))
      ]


instance ToObject (TraceLocalTxSubmissionServerEvent blk) where
  toObject _verb _ =
    mconcat [ "kind" .= String "TraceLocalTxSubmissionServerEvent" ]

instance HasPrivacyAnnotation (TraceGsmEvent selection) where

instance HasSeverityAnnotation (TraceGsmEvent selection) where
  getSeverityAnnotation = \case
    GsmEventEnterCaughtUp{}       -> Notice
    GsmEventLeaveCaughtUp{}       -> Warning
    GsmEventPreSyncingToSyncing{} -> Notice
    GsmEventSyncingToPreSyncing{} -> Notice
    GsmEventInitializedInCaughtUp{}   -> Notice
    GsmEventInitializedInPreSyncing{} -> Notice

instance ToObject selection => Transformable Text IO (TraceGsmEvent selection) where
  trTransformer = trStructured

instance ToObject selection => ToObject (TraceGsmEvent selection) where
  toObject verb (GsmEventEnterCaughtUp i s) =
    mconcat
      [ "kind" .= String "GsmEventEnterCaughtUp"
      , "peerNumber" .= toJSON i
      , "currentSelection" .= toObject verb s
      ]
  toObject verb (GsmEventLeaveCaughtUp s a) =
    mconcat
      [ "kind" .= String "GsmEventLeaveCaughtUp"
      , "currentSelection" .= toObject verb s
      , "age" .= toJSON (show a)
      ]
  toObject _verb GsmEventPreSyncingToSyncing =
    mconcat
      [ "kind" .= String "GsmEventPreSyncingToSyncing"
      ]
  toObject _verb GsmEventSyncingToPreSyncing =
    mconcat
      [ "kind" .= String "GsmEventSyncingToPreSyncing"
      ]
  toObject _verb GsmEventInitializedInCaughtUp =
    mconcat
      [ "kind" .= String "GsmEventInitializedInCaughtUp"
      ]
  toObject _verb GsmEventInitializedInPreSyncing =
    mconcat
      [ "kind" .= String "GsmEventInitializedInPreSyncing"
      ]

instance HasPrivacyAnnotation (TraceGDDEvent peer blk) where
instance HasSeverityAnnotation (TraceGDDEvent peer blk) where
  getSeverityAnnotation _ = Debug
instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk) => Transformable Text IO (TraceGDDEvent peer blk) where
  trTransformer = trStructured

instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk) => ToObject (TraceGDDEvent peer blk) where
  toObject verb (TraceGDDDebug (GDDDebugInfo {..})) = mconcat $
    [ "kind" .= String "TraceGDDEvent"
    , "losingPeers".= toJSON (map (toObject verb) losingPeers)
    , "loeHead" .= toObject verb loeHead
    , "sgen" .= toJSON (unGenesisWindow sgen)
    ] <> do
      guard $ verb >= MaximalVerbosity
      [ "bounds" .= toJSON (
           map
           ( \(peer, density) -> Object $ mconcat
             [ "kind" .= String "PeerDensityBound"
             , "peer" .= toObject verb peer
             , "densityBounds" .= toObject verb density
             ]
           )
           bounds
         )
       , "curChain" .= toObject verb curChain
       , "candidates" .= toJSON (
           map
           ( \(peer, frag) -> Object $ mconcat
             [ "kind" .= String "PeerCandidateFragment"
             , "peer" .= toObject verb peer
             , "candidateFragment" .= toObject verb frag
             ]
           )
           candidates
         )
       , "candidateSuffixes" .= toJSON (
           map
           ( \(peer, frag) -> Object $ mconcat
             [ "kind" .= String "PeerCandidateSuffix"
             , "peer" .= toObject verb peer
             , "candidateSuffix" .= toObject verb frag
             ]
           )
           candidateSuffixes
         )
       ]

  toObject verb (TraceGDDDisconnected peer) = mconcat
    [ "kind" .= String "TraceGDDDisconnected"
    , "peer" .= toJSON (map (toObject verb) $ toList peer)
    ]

instance (Typeable blk, ConvertRawHash blk, GetHeader blk) => ToObject (DensityBounds blk) where
  toObject verb DensityBounds {..} = mconcat
    [ "kind" .= String "DensityBounds"
    , "clippedFragment" .= toObject verb clippedFragment
    , "offersMoreThanK" .= toJSON offersMoreThanK
    , "lowerBound" .= toJSON lowerBound
    , "upperBound" .= toJSON upperBound
    , "hasBlockAfter" .= toJSON hasBlockAfter
    , "latestSlot" .= toJSON (unSlotNo <$> withOriginToMaybe latestSlot)
    , "idling" .= toJSON idling
    ]

instance ConvertRawHash blk => ToObject (Tip blk) where
  toObject _verb TipGenesis =
    mconcat [ "kind" .= String "TipGenesis" ]
  toObject _verb (Tip slotNo hash bNo) =
    mconcat [ "kind" .= String "Tip"
            , "tipSlotNo" .= toJSON (unSlotNo slotNo)
            , "tipHash" .= renderHeaderHash (Proxy @blk) hash
            , "tipBlockNo" .= toJSON bNo
            ]

instance ToObject KESAgentClientTrace where
  toObject _verb (KESAgentClientException exc) =
    mconcat [ "kind" .= String "KESAgentClientException"
            , "exception" .= String (pack $ displayException exc)
            ]
  toObject verb (KESAgentClientTrace trc) =
    mconcat [ "kind" .= String "KESAgentClientTrace"
            , "trace" .= toObject verb trc
            ]

instance HasPrivacyAnnotation KESAgentClientTrace where

instance HasSeverityAnnotation KESAgentClientTrace where
  getSeverityAnnotation = \case
    KESAgentClientException{}       -> Error
    KESAgentClientTrace{}       -> Info

instance Transformable Text IO KESAgentClientTrace where
  trTransformer = trStructured

instance ToObject Agent.ServiceClientTrace where
  toObject _dtal = \case
    Agent.ServiceClientVersionHandshakeTrace _vhdt ->
      mconcat [ "kind" .= String "ServiceClientVersionHandshakeTrace" ]
    Agent.ServiceClientVersionHandshakeFailed ->
      mconcat [ "kind" .= String "ServiceClientVersionHandshakeFailed" ]
    Agent.ServiceClientDriverTrace _sdt ->
      mconcat [ "kind" .= String "ServiceClientDriverTrace" ]
    Agent.ServiceClientSocketClosed ->
      mconcat [ "kind" .= String "ServiceClientSocketClosed" ]
    Agent.ServiceClientConnected _s ->
      mconcat [ "kind" .= String "ServiceClientConnected" ]
    Agent.ServiceClientAttemptReconnect _ _ _ _ ->
      mconcat [ "kind" .= String "ServiceClientAttemptReconnect" ]
    Agent.ServiceClientReceivedKey _tbt ->
      mconcat [ "kind" .= String "ServiceClientReceivedKey" ]
    Agent.ServiceClientDeclinedKey _tbt ->
      mconcat [ "kind" .= String "ServiceClientDeclinedKey" ]
    Agent.ServiceClientDroppedKey ->
      mconcat [ "kind" .= String "ServiceClientDroppedKey" ]
    Agent.ServiceClientOpCertNumberCheck _ _ ->
      mconcat [ "kind" .= String "ServiceClientOpCertNumberCheck" ]
    Agent.ServiceClientAbnormalTermination _s ->
      mconcat [ "kind" .= String "ServiceClientAbnormalTermination" ]
    Agent.ServiceClientStopped ->
      mconcat [ "kind" .= String "ServiceClientStopped" ]

instance HasPrivacyAnnotation Agent.ServiceClientTrace where

instance HasSeverityAnnotation Agent.ServiceClientTrace where
  getSeverityAnnotation = \case
    Agent.ServiceClientVersionHandshakeTrace{} -> Debug
    Agent.ServiceClientVersionHandshakeFailed{} -> Error
    Agent.ServiceClientDriverTrace{} -> Debug
    Agent.ServiceClientSocketClosed{} -> Info
    Agent.ServiceClientConnected{} -> Info
    Agent.ServiceClientAttemptReconnect{} -> Info
    Agent.ServiceClientReceivedKey{} -> Info
    Agent.ServiceClientDeclinedKey{} -> Info
    Agent.ServiceClientDroppedKey{} -> Info
    Agent.ServiceClientOpCertNumberCheck{} -> Debug
    Agent.ServiceClientAbnormalTermination{} -> Error
    Agent.ServiceClientStopped{} -> Info
